BMUG PD-ROM A/PD-ROM A.iso/Programming/Programming Languages/XLISP 2.0/XLISP Tools/Medical (DD)/ADX.LSP

Lisp/Scheme | 1990-04-21 | 43.8 KB | 1,233 lines | [TEXT/ttxt]

;***** XLISP  VERSION 21/04/90 ******


(defvar *all-dd* nil)
(defvar *all-disease* nil)      ;current dd-structs
(defvar *dd-list* nil)
(defvar *disease-list* nil)    ;current dd's
(defvar *dd-slots* '(symptom diseases d-slot))      ;slots of struct dd
(defvar *symptom-list* nil)                  ;symptoms for search-a-disease
(defvar *probable-diseases* nil)             ;resulting diseases from search
(defvar *age-probable* nil)                  ;diseases within age-group
(defvar *morbidity-list* nil)                ;diseases with morbidity-data
(defvar *disease-slots*                      ;slots of struct disease
      '(name                    ; morbidity geographic-occurrence
        age-groups
        sex-predominance        ; m 0.6 f 0.4
        clinical-symptoms
        lab-findings            ; labtest: values [no-values] expl cost
        rx-findings             ; Sy : method frequency expl cost
        sites
        therapy                 ; method:dosage time controls complications
        follow-up
        prognosis-and-complications
        literature              ; ti au publ
        diff-diag               ; other diseases: differentiation to act
        general-description
        property-slot
        codes
        reserve1 reserve2 reserve3 reserve4 reserve5))

(defvar *prop-list* '(freq explanation methods normal-values cost time
                      morbidity geographic-occurrence dosage
                      overdose-reactions))     ;possible properties of slots
(defvar *all-symptoms* nil)
(defvar *all-symptoms-string* nil)
(defvar *flag* nil)
(defvar *line-cnt* 0)
(defvar *struct* nil)
(defvar *test-struct* nil)
(defvar *all-string-list* nil)


(defmacro pop (stack)
  `(let ((x (car ,stack)))
        (setq ,stack (cdr ,stack))
        x))

(defmacro push (thing stack)
  `(setq ,stack (cons ,thing ,stack)))

;****** accessors *********
(defmacro symptom (dd) `(car ,dd))
(defmacro diseases (dd) `(car (cdr ,dd)))
(defmacro d-slot  (dd) `(car (cddr ,dd)))

(defmacro name (disease) `(car ,disease))
(defmacro age-groups (disease) `(car (cdr ,disease)))
(defmacro sex-predominance (disease) `(car (cddr ,disease)))
(defmacro clinical-symptoms (disease) `(car (cdddr ,disease)))
(defmacro lab-findings (disease) `(car (cddddr ,disease)))
(defmacro rx-findings (disease) `(car (cdr (cddddr ,disease))))
(defmacro sites (disease) `(car (cddr (cddddr ,disease))))
(defmacro therapy (disease) `(car (cdddr (cddddr ,disease))))
(defmacro follow-up (disease) `(car (cddddr (cddddr ,disease))))
(defmacro prognosis-and-complications (disease)
                                `(car (cdr (cddddr (cddddr ,disease)))))
(defmacro literature (disease) `(car (cddr (cddddr (cddddr ,disease)))))
(defmacro diff-diag (disease) `(car (cdddr (cddddr (cddddr ,disease)))))
(defmacro general-description (disease)
       `(car (cddddr (cddddr (cddddr ,disease)))))
(defmacro property-slot (disease)
       `(car (cdr (cddddr (cddddr (cddddr ,disease))))))
(defmacro codes (disease)
       `(car (cddr (cddddr (cddddr (cddddr ,disease))))))
(defmacro reserve1 (disease)
       `(car (cdddr (cddddr (cddddr (cddddr ,disease))))))
(defmacro reserve2 (disease)
       `(car (cddddr (cddddr (cddddr (cddddr ,disease))))))
(defmacro reserve3 (disease)
       `(car (cdr (cddddr (cddddr (cddddr (cddddr ,disease)))))))
(defmacro reserve4 (disease)
       `(car (cddr (cddddr (cddddr (cddddr (cddddr ,disease)))))))
(defmacro reserve4 (disease)
       `(car (cdddr (cddddr (cddddr (cddddr (cddddr ,disease)))))))
(defmacro reserve5 (disease)
       `(car (cddddr (cddddr (cddddr (cddddr (cddddr ,disease)))))))
(defmacro prop-symptom (propl) `(car ,propl))
(defmacro prop-property (propl) `(car (cdr ,propl)))
(defmacro prop-value (propl) `(car (cddr ,propl)))

(defmacro make-name (&rest args)
 `(intern (format nil "~a" ,@args)))

;******* constructors *********
(defun make-dd () (list () () ()))
(defun make-disease () (list () () () () ()
                             () () () () ()
                             () () () () ()
                             () () () () ()))

;******** menus *********
(defun make-it ()
  (read-in)
  (top-round))

(defun top-round ()
  (format t "~%main~%")
  (funcall
      (make-menu '(work-on-dd work-on-diseases work-on-slots
                      general-routines
                      search-and-analyse
                      save-work stop-all))))

(defun stop-all () (break))

(defun save-work ()
 (save-dd) (save-diseases))

(defun work-on-dd ()
  (loop (funcall (make-menu '(show-a-dd show-all-dd
                                 make-a-dd delete-a-dd clear-dd
                                 make-dd-from-diseases
                                 make-diseases-from-dd
                                 go-back)))))

(defun work-on-diseases ()
  (loop (funcall (make-menu '(add-a-disease delete-a-disease
                 change-a-disease find-it change-all-instances
                 set-disease-properties
                 show-a-disease show-all-diseases show-a-full-disease
                 search-a-disease-incremental
                 go-back)))))

(defun work-on-slots ()
  (loop (funcall (make-menu '(add-to-existing-slot delete-slot
                                 collect-and-sort-symptoms find-it
                                 sort-symbols
                                 go-back)))))
(defun general-routines ()
  (loop (funcall (make-menu '(collect-and-sort-symptoms sort-symbols
                                 find-it change-all-instances
                                 print-list-to-file
                                 go-back)))))
(defun search-and-analyse ()
  (loop (funcall (make-menu '(search-a-disease-incremental
                                 difference-analysis
                                 check-the-age-group
                                 print-list-to-file
                                 go-back)))))
(defun go-back () (top-round))

;************ make dd from diseases *****************
;   checks every symptom in the slots
;        clinical-findings
;        lab-findings
;        rx-findings
;  adds the name fo a disease to the differential-struct
;  or builds a new differential-struct

(defun make-dd-from-diseases ()
  (let ((d nil) (slots '(clinical-symptoms lab-findings rx-findings)))
    (dolist (structnam *disease-list*)
      (setf d (get-struct *all-disease* structnam 'name))
      (PRINT structnam)
      (dolist (s slots)
        (check-slot s d)))))

(defun check-slot (slot dise)
  (let ((vall (get-slot-value slot dise)))
    (cond ((null vall) nil)
          (t (dolist (v (setf vall (make-sure-list vall)))
               (if (member v *dd-list*) (add-dd v dise)
                   (new-dd v dise slot)))))))

;    creates a new differential

(defun new-dd (sy dis slo)
  (let ((dd (make-dd)))
    (cond ((null sy) nil)
          (t
              (setf *dd-list* (add-to-list *dd-list* sy))
              (setf (symptom dd) sy)
              (setf (diseases dd) (name dis))
              (setf (d-slot dd) slo)
              (setf *all-dd* (add-to-list *all-dd* dd))))))

; adds the disease-name to an existing differential

(defun add-dd (sy dis)
  (let ((struct (get-struct *all-dd* sy 'symptom)))
    (if (null struct) (error "discrepancy between *dd-list* and *all-dd"))
    (cond ((null sy) nil)
          (t
              (setf *all-dd* (delete-from-list *all-dd* struct))
              (cond ((null (diseases struct))
                     (setf struct (set-slot-value struct 'diseases (name dis))))
                    ((listp (diseases struct))
                     (if (member (name dis) (diseases struct)) nil
                         (setf struct (set-slot-value struct 'diseases
                                        (cons (name dis) (diseases struct))))))
                    ((atom (diseases struct))
                     (if (equal (name dis) (diseases struct)) nil
                         (setf struct (set-slot-value struct 'diseases
                             (cons (name dis) (list (diseases struct))))))))
              (setf *all-dd* (add-to-list *all-dd* struct))))))

;*********** make-diseases-from-dd *****************
; makes disease-structs from differentials

(defun make-diseases-from-dd ()
  (let ((struct nil))
    (dolist (sym *dd-list*)
      (setf struct (get-struct *all-dd* sym 'symptom))  ;dd-symptom
      (cond ((null struct)
            (format t "~%discrepancy between *disease-list* and *all-disease*"))
            (t (update-diseases-with-dd-symptom struct))))))

(defun update-diseases-with-dd-symptom (struct)
  (let ((dis nil))
    (PRINT (SYMPTOM STRUCT))
    (dolist (act-dis (make-sure-list (diseases struct)))
      (setf dis (get-struct *all-disease* act-dis 'name))
      (cond ((null (symptom struct)) nil)
            ((null dis) (new-disease-from-dd
                      act-dis (symptom struct) (d-slot struct)))
            (t (old-disease-from-dd dis (symptom struct) (d-slot struct)))))))

;   makes a new disease

(defun new-disease-from-dd (dis sym sl)
  (let ((str (make-disease)))
    (setf sym (make-sure-list sym))
    (if (null sl) (setf sl 'clinical-symptoms))
    (setf (name str) dis)                       ; set name
    (setf str (set-slot-value str sl sym))      ; set symptom ins slot sl
    (setf *all-disease* (add-to-list *all-disease* str))
    (setf *disease-list* (add-to-list *disease-list*  dis))))

;   adds the symptom to an existing disease-struct

(defun old-disease-from-dd (dis sym slot)
  (let ((vall nil))
    (cond ((null sym) nil)
          (t  (if (null slot) (setf slot 'clinical-symptoms))
              (setf vall (get-slot-value slot dis))
              (cond ((null vall)
                     (setf *all-disease* (delete-from-list *all-disease* dis))
                     (setf dis (set-slot-value dis slot (list sym)))
                     (setf *all-disease* (add-to-list *all-disease* dis)))
                    ((listp vall)
                     (if (member sym vall) nil (old-diseases2 dis sym slot)))
                    ((atom vall)
                     (if (equal sym vall) nil (old-diseases2 dis sym slot)))
                    (t nil))))))

(defun old-diseases2 (dis sym slot)
  (let ((vall nil))
    (setf *all-disease* (delete-from-list *all-disease* dis))
    (setf vall (get-slot-value slot dis))
    (setf vall (make-sure-list vall))
    (setf vall (cons sym vall))
    (setf dis (set-slot-value dis slot vall))
    (setf *all-disease* (add-to-list *all-disease* dis))))

;****** find any word in any slot *************

(defun find-it ()
  (let ((fi nil))
    (setf *struct* nil)
    (format t "~%FIND~%")
    (setf fi (ask-for-which))
    (find-it-helper *all-disease* *disease-slots* fi)
    (cond ((null *struct*)
           (find-it-helper *all-dd* *dd-slots* fi)
           (cond ((null *struct*) (format t "~%sorry nothing found~%"))
                 (t (format t "~%found it in dd~%"))))
          (t (format t "~%found it in diseases~%")))
    (print-list *struct*)))

(defun find-it-helper (struct-list slot-list what)
  (let ((slot-value nil))
    (dolist (dis  (setf struct-list (make-sure-list struct-list)))
      (dolist (slot  (setf slot-list (make-sure-list slot-list)))
        (setf slot-value (get-slot-value slot dis))
        (cond ((null slot-value) nil)
              ((atom slot-value) (if (equal what slot-value)
                              (setf *struct* (cons (name dis) *struct*))))
              ((listp slot-value) (if (member what slot-value)
                               (setf *struct* (cons (name dis) *struct*)))))))))

;******** disease work **************
;  database-function  'add

(defun add-a-disease ()
  (let ((temp nil) (stemp nil))
    (format t "~%DISEASE - ADD")(terpri)
    (setf temp (ask-for-which))
    (cond ((member temp *disease-list*)(format t "disease exists !"))
          (t  (setf *disease-list* (add-to-list *disease-list* temp))
              (setf stemp (make-disease))
              (setf (name stemp) temp)
              (setf stemp (fill-slots stemp))
              (setf *all-disease* (add-to-list *all-disease* stemp))
              ))))

;   database-function 'delete

(defun delete-a-disease ()
  (let ((temp nil))
    (format t "~%DISEASE - DELETE")(terpri)
    (setf temp (ask-for-which))
    (delete-helper temp)))

(defun delete-helper (temp)
  (let ((del nil))
   (cond ((not (member temp *disease-list*))
          (format t "disease does not exist !"))
         (t (setf *disease-list* (delete-from-list *disease-list*  temp))
            (setf del (get-struct *all-disease* temp 'name))
            (setf *all-disease* (delete-from-list *all-disease* del))
            ))))

;  database-function 'change

(defun change-a-disease ()
  (let ((which nil) (struct nil))
    (format t "~%DISEASE-CHANGE~%")
    (setf which (ask-for-which))
    (cond ((member which *disease-list*)
           (setf struct (get-struct *all-disease* which 'name))
           (format t "~%old values for ~a~%" which)
           (print-disease struct)
           (delete-helper which)
           (change-helper struct)
           (setf *all-disease* (add-to-list  *all-disease* struct))
           (setf *disease-list* (add-to-list *disease-list* (name struct))))
          (t (format t "~%cannot find ~a in disease-list~%" which)))))

(defun change-helper (struct)
  (let ((success nil) (oval nil) (slot-contains nil))
    (loop
      (format t "~%value to change (stop with nil) : ")
      (setf success nil)
      (setf oval (read))
      (cond ((null oval) (return struct))
            (t (dolist (sl *disease-slots*)
                 (setf slot-contains (get-slot-value sl struct))
                 (cond ((null slot-contains) nil)
                       ((atom slot-contains)
                        (cond ((equal oval slot-contains)
                               (setf success 'ok)
                               (change-helper2 struct sl slot-contains oval))))
                       ((listp slot-contains)
                        (cond ((member oval slot-contains)
                               (setf success 'ok)
                               (change-helper2 struct sl slot-contains oval)))))
                 (if (equal success 'ok) (return struct))))))))

(defun change-helper2 (str sl slc oval)
  (let ((nval nil))
    (progn
      (format t "~%new value for ~a : " oval)
      (setf nval (read))
      (if (atom slc) (setf slc nval))
      (if (listp slc) (setf slc (cons nval (delete oval slc))))
      (set-slot-value str sl slc)
      str)))

;*********** change-all-instances **************

(defun change-all-instances ()
(let ((newvalue nil) (oldvalue nil))
  (format t "~%change all instances")
  (format t "~%old value: ")
  (setf oldvalue (read))
  (cond ((null oldvalue) (return))
        (t (format t "~%new value: ")
           (setf newvalue (read))))
  (cond ((null newvalue) nil)
        (t (change-all-instances-helper oldvalue newvalue
                                *all-disease* *disease-list* *disease-slots*)
           (change-all-instances-helper oldvalue newvalue
                         *all-dd* *dd-list* *dd-slots*)))))

(defun change-all-instances-helper
              (oldvalue newvalue struct-list name-list slot-list)
  (let ((slot-contains nil) (struct nil))
    (dolist (structnam name-list)
      (setf struct (get-struct struct-list structnam 'name))
      (cond ((null struct)
             (format t "~%error in change/inst-help ~a~%" structnam))
        (t
          (setf struct-list (delete-from-list struct-list struct))
          (dolist (sl slot-list)
            (setf slot-contains (get-slot-value sl struct))
            (cond ((null slot-contains) nil)
                  ((atom slot-contains) (if (equal slot-contains oldvalue)
                            (setf struct (set-slot-value struct sl newvalue))))
                  ((listp slot-contains)
                   (if (member oldvalue slot-contains)
                       (setf struct (set-slot-value struct sl
                              (setf slot-contains (cons newvalue
                                    (delete oldvalue slot-contains)))))))))
          (setf struct-list (add-to-list struct-list struct)))))))

;******* search-a-disease-incremental *********
; search the database (logical 'and)

(defun search-a-disease-incremental ()
  (let ((dd *disease-list*) (ant nil))
    (setf *symptom-list* nil) (setf *probable-diseases* nil)
    (loop
      (format t "~%DD-SEARCH") (terpri)
      (if (atom dd) (format t "~%last disease : ~a" dd)
          (if (< 30 (length dd))
              (format t "~%more than 30 diseases left")
              (format t "remaining diseases ~%~a" dd)))
      (terpri)
      (format t "~%give me a symptom (nil = stop, new = again)~%")
      (setf ant (ask-for-which))
      (cond ((null ant) (setf *probable-diseases* dd) (return))
            ((eql 'new ant)  (setf dd *disease-list* ant nil)
             (setf *symptom-list* nil) (setf *probable-diseases* nil))
            (t  (setf dd (search-helper ant dd 's-and))))
      )))

(defun search-helper (ant dd afunc)
  (let ((act nil))
      (cond ((equal ant nil) nil)
            ((member ant *dd-list*)
             (setf *symptom-list* (add-to-list *symptom-list* ant))
             (setf act (get-struct *all-dd* ant 'symptom))
             (cond ((equal (symptom act) ant)
                    (if (listp (diseases act))
                           (setf dd (funcall afunc dd (diseases act)))
                           (setf dd (diseases act))))
                   (t (format t "~%symptom ~a not equal in struct ~a~%"
                              ant (symptom act)))))
            (t (format t "~%symptom is not in dd-list~%")))
      dd))


(defun s-and (dd diseases)
  (my-intersection dd diseases))

(defun s-or (dd diseases)
  (union dd diseases))

(defun s-not (dd diseases)
  (set-difference dd diseases))


;******* print functions *********
(defun print-dd (struct)
  (cond ((null struct) (format t "sorry, no dd to print !")(terpri))
        (t  (terpri) (format t "symptom : ~a" (symptom struct))
            (terpri) (format t "diagnoses: ")(terpri)
            (print-list (diseases struct)))))

(defun print-to-file (text file)
  (dolist (x text)
    (princ x file) (terpri file)))

(defun print-list-to-file ()
  (let ((nam nil) (fp nil) (ll nil))
    (format t "~%filename : ")
    (setf nam (read))
    (format t "~%list : ")
    (setf ll (eval (read)))
    (setf fp (open nam :direction :output))
    (dolist (x (setf ll (make-sure-list ll)))
      (princ x fp) (terpri fp))
    (close fp)))

(defun print-list (l)
  (setf *line-cnt* 0)
  (cond ((null l) (format t "sorry, no list to print !")(terpri))
        ((atom l) (print l) (terpri))
        (t (dolist (x l) (print-and-count-lines x))
           (wait-for-answer)
           (terpri))))

(defun print-and-count-lines (lin)
  (cond ((>= *line-cnt* 15)  (wait-for-answer)
         (print lin) (setf *line-cnt* 0))
        (t (print lin) (setf *line-cnt* (+ 1 *line-cnt*)))))

(defun wait-for-answer ()
 (read-char))

(defun print-disease (struct)
  (let ((ms nil))
    (cond ((null struct) (format t "~%sorry, no disease to print ") (terpri))
          (t   (dolist (m *disease-slots*)
                 (setf ms (get-slot-value m struct))
                 (cond ((null ms) nil)
                       (t   (terpri)(princ m) (princ " : ")
                            (princ ms))))))
    (terpri)))

(defun print-full-disease (struct)
  (cond ((null struct) (format t "~%sorry, no disease to print ") (terpri))
        (t   (dolist (m *disease-slots*)
               (terpri)(princ m) (princ " : ")
               (princ (get-slot-value m struct)))))
  (terpri))

;********* word-root functions *******
; don't use it on an PC, takes hell of time

(defun make-word-root-list ()
  (let ((*all-symptoms* (read-list-from-file "asymptom.txt")))
    (dolist (x *all-symptoms*)
      (checklist x (get-single-words x)))
 (write-list-to-file *word-root-list* "asymptom.rot")))

(defun get-single-words (word)
  (let ((wname (symbol-name word)) (word-list nil) (input nil))
    (setf word-list (substitute #\  #\- wname))
    (setf input (make-string-input-stream word-list))
    (do ((x (read input nil) (read input nil))
         (sentence nil))
        ((not x) (return (reverse sentence)))
      (push x sentence))))

(defun checklist (full-word word)
  (let ((struct (get-hlist (car word))))
    (if (null struct) (put-hlist full-word (car word))
         (if (setf struct (checklist2 full-word (make-sure-list struct)))
                          (put-hlist struct (car word))))))

(defun checklist2 (full-word struct)
  (dolist (x struct)
    (if (eq x full-word) (return)))
  (setf struct (append (make-sure-list struct) (make-sure-list full-word)))
struct)

(defun put-hlist (wlist nkey)
  (let ((temp nil))
  (setf temp (assoc nkey *word-root-list*))
  (setf *word-root-list* (delete-from-list *word-root-list* temp))
  (setf *word-root-list* (add-to-list *word-root-list*
                             (append (list nkey) (make-sure-list wlist))))))

(defun get-hlist (nkey)
  (cdr (assoc nkey *word-root-list*)))

;********* menu /display **************

(defun make-menu (li)
  (cond ((null li) nil)
        (t (display-menu li))))

(defun display-menu (li)
  (let ((long (length li)))
    (cond ((> long 29) (format t "~%menu with ~a entries too long!~%" long))
          ((> long 15) (display-single-menu li long))
          (t           (display-single-menu li long)))))

(defun display-single-menu (li long)
  (terpri)
  (dotimes (x long)
    (format t "~%~a     ~a" (1+ x) (nth x li)))
  (get-numbered-answer li long))

(defun display-double-menu (li long)
  (let ((half (round (+ 0.5 (/ long 2)))))
    (dotimes (x (1+ half))
      (cond ((null (nth x li)) nil)
            (t (format t "~&~D  ~A~36t" (1+ x) (nth x li))))
      (cond ((null (nth (1+ (+ x half)) li)) nil)
            (t (format t "~D  ~A" (+ 2 (+ x half)) (nth (1+ (+ x half)) li)))))
    (get-numbered-answer li long)))

(defun get-numbered-answer (li long)
  (let ((ans nil))
    (format t "~%Enter a number between 1 and ~a~%" long)
    (setf ans (read))
    (cond ((not (numberp ans)) (get-numbered-answer li long))
          ((null ans) (get-numbered-answer li long))
          ((or (< long ans) (> 0 ans)) (get-numbered-answer li long))
          (t (nth (1- ans) li)))))

;******** file functions *********
(defun read-in () (read-diseases) (read-dd)
       (read-symptoms))

(defun read-dd ()
  (format t "~%reading dd-files~%")
  (setf *all-dd* (read-list-from-file "dd.txt"))
  (format t "~%constructing *dd-list*~%")
  (setf *dd-list* (get-cars *all-dd*)))

(defun save-dd ()
  (format t"~%saving dd-files~%")
  (write-list-to-file *all-dd* "dd.txt"))

(defun read-diseases ()
  (format t"~%reading disease-files~%")
  (setf *all-disease* (read-list-from-file "diseases.txt"))
  (format t "~%constructing *disease-list*~%")
  (setf *disease-list* (get-cars *all-disease*)))

(defun save-diseases ()
  (format t"~%saving disease-files~%")
  (write-list-to-file *all-disease* "diseases.txt"))

(defun read-symptoms ()
(format t"~%reading symptom-files")
(setf *all-symptoms* (read-list-from-file "asymptom.txt"))
(setf *word-root-list* (read-list-from-file "asymptom.rot")))

(defun read-list-from-file (filename)
(let ((listname nil)
      (fp (open filename :direction :input)))
(progn
  (do* ((ex nil)
     (ex (read fp) (read fp)))
     ((null ex) (close fp))
 (setf listname (cons ex listname)))
 listname)))

(defun write-list-to-file (listname filename)
(let ((listname (make-sure-list listname))
      (fp (open filename :direction :output)))
(dolist (x listname)
 (print x fp))
(close fp)))

;******** slot functions *********
; access and fill the subparts of the disease-struct

(defun fill-slots (struct)
  (let ((antw nil) (tx (cons 'return (cdr *disease-slots*))))
    (loop
      (setf antw (make-menu tx))
      (cond ((equal antw 'return) (return struct))
            ((member antw *disease-slots*)
             (setf struct (put-slot struct antw)))
            (t (format t "error: non-existing slot in fill-slots !"))))))

(defun put-slot (struct antw)
  (let ((temp (make-sure-list (input-list))))
    (set-slot-value struct antw temp)))

(defun set-slot-value (struct antw temp)
  (progn
    (case antw
      (name (setf (name struct) temp))
      (age-groups (setf (age-groups struct) temp))
      (sex-predominance (setf (sex-predominance struct) temp))
      (clinical-symptoms (setf (clinical-symptoms struct) temp))
      (lab-findings (setf (lab-findings struct) temp))
      (rx-findings (setf (rx-findings struct) temp))
      (sites (setf (sites struct) temp))
      (therapy (setf (therapy struct) temp))
      (follow-up (setf (follow-up struct) temp))
      (prognosis-and-complications
          (setf (prognosis-and-complications struct) temp))
      (literature (setf (literature struct) temp))
      (diff-diag (setf (diff-diag struct) temp))
      (general-description (setf (general-description struct) temp))
      (property-slot (setf (property-slot struct) temp))
      (codes (setf (codes struct) temp))
      (reserve1 (setf (reserve1 struct) temp))
      (reserve2 (setf (reserve2 struct) temp))
      (reserve3 (setf (reserve3 struct) temp))
      (reserve4 (setf (reserve4 struct) temp))
      (reserve5 (setf (reserve5 struct) temp))
;(clinical-symptoms-props (setf (clinical-symptoms-props struct) temp))
;(lab-findings-props (setf (lab-findings-props struct) temp))
;(rx-findings-props (setf (rx-findings-props struct) temp))
      (symptom (setf (symptom struct) temp))
      (diseases (setf (diseases struct) temp))
      (d-slot (setf (d-slot struct) temp)))
    struct))

(defun get-slot-value (antw struct)
  (let ((result nil))
    (progn
      (case antw
        (name (setf result (name struct)))
        (age-groups (setf result (age-groups struct)))
        (sex-predominance (setf result (sex-predominance struct)))
        (clinical-symptoms (setf result (clinical-symptoms struct)))
        (lab-findings (setf result (lab-findings struct)))
        (rx-findings (setf result (rx-findings struct)))
        (sites (setf result (sites struct)))
        (therapy (setf result (therapy struct)))
        (follow-up (setf result (follow-up struct)))
        (prognosis-and-complications
            (setf result (prognosis-and-complications struct)))
        (literature (setf result (literature struct)))
        (diff-diag (setf result (diff-diag struct)))
        (general-description (setf result (general-description struct)))
        (property-slot (setf result (property-slot struct)))
        (codes (setf result (codes struct)))
        (reserve1 (setf result (reserve1 struct)))
        (reserve2 (setf result (reserve2 struct)))
        (reserve3 (setf result (reserve3 struct)))
        (reserve4 (setf result (reserve4 struct)))
        (reserve5 (setf result (reserve5 struct)))
;(clinical-symptoms-props (setf result (clinical-symptoms-props struct)))
;(lab-findings-props (setf result (lab-findings-props struct)))
;(rx-findings-props (setf result (rx-findings-props struct)))
        (symptom (setf result (symptom struct)))
        (diseases (setf result (diseases struct)))
        (d-slot (setf result (d-slot struct))))
      result)))

(defun input-list ()
  (let ((temp nil))
    (progn
      (format t "~%list-input (terminate with nil):~%")
      (do ((input (read-sentence) (read-sentence)))   ;start
          ((equal nil input)  temp)                  ; end
        (setf temp (append input temp))))))        ;body

; works on a part of a disease-struct
; 'delete' function

(defun delete-slot ()
  (let ((dis nil))
    (format t "~%DISEASE-DELETE-SLOT~%")
    (format t "~%INPUT DISEASE~%")
    (setf dis (ask-for-which))
    (cond ((null dis) nil)
          ((member dis *disease-list*)
           (delete-slot-helper
               (get-struct *all-disease* dis 'name)))
          (t (format t "~%unknown error in delete-slot ~a~%" dis)))))

(defun delete-slot-helper (struct)
  (let ((slot nil) (tempstruct nil))
    (loop
      (format t "~%ACTUAL VALUES~%")
      (print-disease struct)
      (format t "~%INPUT SLOT~%")
      (setf slot (make-menu (cons 'return *disease-slots*)))
      (cond ((equal 'return slot)
             (delete-from-list *all-disease* tempstruct)
             (setf *all-disease* (add-to-list *all-disease* struct))
             (return))
            (t (setf struct (set-slot-value struct slot nil)))))))

;  works on a part of the disease-struct
;  'add' function
(defun add-to-existing-slot ()
  (let ((dis nil))
    (format t "~%DISEASE-ADD-TO-SLOT~%")
    (format t "~%INPUT DISEASE~%")
    (setf dis (ask-for-which))
    (cond ((null dis) nil)
          ((member dis *disease-list*)
           (add-to-existing-slot-helper
               (get-struct *all-disease* dis 'name)))
          (t (format t "~%unknown error in add-to-existing-slot ~a~%" dis)))))

(defun add-to-existing-slot-helper (struct)
  (let ((slot nil) (tempstruct nil))
    (loop
      (format t "~%ACTUAL VALUES~%")
      (print-disease struct)
      (format t "~%INPUT SLOT~%")
      (setf slot (make-menu (cons 'return *disease-slots*)))
      (cond ((equal 'return slot)
             (delete-from-list *all-disease* tempstruct)
             (setf *all-disease* (add-to-list *all-disease* struct))
             (return))
            (t (setf struct (add-to-existing-slot-helper2 slot struct)))))))

(defun add-to-existing-slot-helper2 (slot struct)
  (let ((temp nil))
    (format t "~%ACTUAL VALUES FOR SLOT ~a~%" slot)
    (print (get-slot-value slot struct)) (terpri)
        (setf temp (input-list))
    (set-slot-value struct slot (append (get-slot-value slot struct) temp))))

; because the file-save did not work with symbols and properties
; I put the properties in a special slot of a disease-struct

(defun set-disease-properties ()
  (let ((which nil))
    (format t "~%DISEASE-PROPERTIES~%")
    (format t "~%INPUT DISEASE~%")
    (setf which (ask-for-which))
    (cond ((null which) nil)
          ((member which *disease-list*)
           (set-disease-properties-helper
               (get-struct *all-disease* which 'name)))
          (t (format t "~%cannot find ~a in disease-list~%" which)))))

(defun set-disease-properties-helper (struct)
  (format t "~%values for ~a~%" (name struct))
  (delete-helper (name struct))
  (setf struct (change-properties struct))
  (setf *all-disease* (add-to-list *all-disease* struct))
  (setf *disease-list* (add-to-list *disease-list* (name struct))))

(defun change-properties (struct)
  (let ((slot 'property-slot) (symp nil) (pr nil)
        (val nil) (x nil))
    (loop
      (print-disease struct)
      (format t"~%symptom :~%")
      (setf symp (read))
      (if (null symp) (return struct))
      (format t "~%property :~%")
      (setf pr (make-menu (cons 'return *prop-list*)))
      (if (equal 'return pr) (return struct))
      (format t "~%property-value for symbol ~a , property ~a.~%" symp pr)
      (setf val (read))
      (if (or (null val) (equal 'return val)) (return struct))
      (setf x (cons (list symp pr val)(get-slot-value slot struct)))
      (setf struct (set-slot-value struct slot x)))))

;******* collecting and sorting **********
; collects all existing symptoms and writes it to file
; 'asymptom.txt'

(defun collect-and-sort-symptoms ()
(let ((slots '(clinical-symptoms lab-findings rx-findings))
       (dis nil))
  (setf *all-symptoms* '(cough fever))
  (dolist (structnam *disease-list*)
    (setf dis (get-struct *all-disease* structnam 'name))
    (cond ((null dis) (format t "~%discrepancy *all-disease* / *disease-list*~%"))
          (t (do-slots slots dis))))
  (setf *all-symptoms* (sort-them *all-symptoms*))
  (format t "~%writing to symptoms to disk")
  (write-list-to-file *all-symptoms* "asymptom.txt")
  (format t "~%saved symptoms~%")))

(defun do-slots (slots dis)
(let ((slot-values nil))
  (dolist (slot slots)
    (setf slot-values (get-slot-value slot dis))
    (cond ((null slot-values) nil)
          (t (do-slot-values slot-values))))))

(defun do-slot-values (slot-values)
(let ((slot-values (make-sure-list slot-values)))
  (dolist (sym slot-values)
    (cond ((null sym) nil)          ;empty slot
          ((member sym *all-symptoms*) nil)
          (t (setf *all-symptoms* (cons sym *all-symptoms*)))))))


;****** general functions ***************
; sorts any list of symbols by their 'alphabetic' rank

(defun sort-symbols ()
  (let ((lst nil))
    (format t "~%input symbol-list~%")
    (setf lst (read))
    (cond ((member lst '(*all-disease* *all-dd*))
           (format t "~% invalid value"))
          (t (sort-them (eval lst))))))

(defun sort-them (sylist)
  (let ((rst nil))
    (progn
      (setf *all-string-list* nil)
      (dolist (x (setf sylist (make-sure-list sylist)))
        (setf *all-string-list* (cons (zap-to-string x) *all-string-list*)))
      (setf *all-string-list* (sort *all-string-list* #'string>))
      (dolist (x (setf *all-string-list* (make-sure-list *all-string-list*)))
        (setf rst (cons (make-name x) rst)))
      rst)))


; read an input terminated by 'nil
; and return the symbols

(defun read-sentence ()
  (let ((input nil) (input2 nil))
    (setf input2 (string-trim ".,?!" (read-non-empty-line)))
    (setf input (make-string-input-stream input2))
    (do ((word (read input nil)(read input nil))
         (sentence nil))
        ((not word) (return (reverse sentence)))
      (push word sentence))))

; ask

(defun ask-for-which ()
  (format t "~%which one please ?")
  (read))

; if its no list --> then make one

(defun make-sure-list (tmp)
  (progn
    (cond ((atom tmp) (setf tmp (list tmp)))
          ((listp tmp) nil)
          (t (format t"~%error making list from ~a~%" tmp)))
    tmp))

; ignore empty inputs

(defun read-non-empty-line ()
  (let ((result nil))
    (loop
      (setq result (read-line))      (if (= (length result) 0) nil
          (return result)))))

; get the first symbol of every list in a list

(defun get-cars (ll)
(let ((res nil))
  (dolist (x ll)
    (setf res (cons (car x) res)))
res))

; Common lisp function

(defun remove-duplicates (lsta)
(let ((result nil))
  (dolist (x lsta)
   (cond ((member x result) nil)
         (t (setf result (cons x result)))))
result))

;**** show functions ******
(defun show-a-dd ()
 (print-dd (get-struct
             *all-dd* (ask-for-which) 'symptom)))
(defun show-all-dd ()
  (print-list *dd-list*))

(defun show-a-disease ()
  (print-disease (get-struct *all-disease* (ask-for-which)
                  'name)))
(defun show-a-full-disease ()
  (print-full-disease (get-struct *all-disease* (ask-for-which)
                  'name)))

(defun show-all-diseases ()
   (print-list *disease-list*))


;********** struct-operations ************
; accessor for diseases and differentials
; could be replaced by a hash-list or files or ...
; as long as every call goes by these functions,
; the real type of the list is not important and easy to change

(defun get-struct (struct-list which slot-name)
  (dolist (m (setf struct-list (make-sure-list struct-list)))
    (if (equal (get-slot-value slot-name m) which)
        (return m))))

(defun delete-from-list (struct-list which)
  (setf struct-list (delete which struct-list)))

(defun add-to-list (struct-list what)
  (setf struct-list (cons what struct-list)))

;************** differentials ****************
;   database-function 'create'

(defun make-a-dd ()
  (let ((tt nil) (ddtemp nil))
    (format t "~%Differentials Entry")
    (format t "~%-------------------")
    (terpri)
    (format t "~%DD - Symptom : ")
    (setf tt (read))
    (cond ((null tt) nil)
          ((member tt *dd-list*)
                         (format t "Symptom exists already !"))
          (t (setf *dd-list* (add-to-list *dd-list* tt))
             (setf ddtemp (make-dd)) (setf (symptom ddtemp) tt)
             (setf (diseases ddtemp) (input-dd-diseases))
             (format t "~%slot :~%")
             (setf (d-slot ddtemp) (make-menu *disease-slots*))
             (setf *all-dd* (add-to-list *all-dd*  ddtemp))))))

(defun input-dd-diseases ()
  (let ((temp nil))
    (progn
      (format t "~%DD - diseases : ")
      (do ((input (read-sentence) (read-sentence)))     ;start
          ((equal nil input)  (if (atom temp) (list temp))
                                                temp)   ; end
        (setf temp (append input temp)))                ;body
(if (atom temp) (list temp) temp))))

; database-function 'delete' for differentials

(defun delete-a-dd ()
  (let ((del nil) (del2 nil))
    (format t "~%DELETE DD :~%")
    (setf del (ask-for-which))
    (cond ((member del *dd-list*)
           (setf *dd-list* (delete-from-list *dd-list* del))
           (setf del2 (get-struct *all-dd* del 'symptom))
           (setf *all-dd* (delete-from-list *all-dd* del2)))
          (t (format t "~%unable to delete ~a~%" del)))))

; in case you did something wrong

(defun restore-disease-list ()
  (setf *disease-list* nil)
    (setf *disease-list* (get-cars *all-disease*)))

(defun restore-dd-list ()
  (setf *dd-list* nil)
    (setf *dd-list* (get-cars *all-dd*)))

;********* analyse search-results ***********
; display the difference in symptoms of 2 diseases
; the result of the last search is stored in
; the symbol *probable-diseases*

(defun difference-analysis ()
(let* ((len (length *probable-diseases*))
       (symptom-array (make-array (* len len)))
       (place 0) (sx nil))
                               ;collect-all-symptoms-from-one-disease
(dolist (dis (setf *probable-diseases* (make-sure-list *probable-diseases*)))
 (setf sx (collect-symps dis))
 (setf (aref symptom-array place) sx)
 (setf place (+ place len)))
(setf result-array (do-difference symptom-array len))
(print-result-array *probable-diseases* result-array len)))

; print-result of analysis

(defun print-result-array (pd res len)
(let ((start 0) (next -1))
(dotimes (x (* len len))
 (setf next (1+ next))
 (cond ((equal next len) (setf next 0) (setf start (1+ start)))
       (t  nil))
  (format t "~%~a differs from  ~a~%" (nth start pd) (nth next pd))
  (print (aref res x))
  (format t "~% press any key to continue~%") (wait-for-answer)
   )))

(defun do-difference (symptom-array len)
(let ((r-array (make-array (* len len))) (start nil))
(progn
(dotimes (x len)
 (setf start (* x len))
 (dotimes (y len)
  (setf (aref r-array (+ start y))
         (set-difference (aref symptom-array start)
                     (aref symptom-array (* len y))))))
r-array)))

(defun collect-symps (nam)
(let ((rt nil) (temp nil)
      (slot-list '(clinical-symptoms lab-findings rx-findings))
      (struct (get-struct *all-disease* nam 'name)))
(dolist (slot slot-list)
 (setf temp (get-slot-value slot struct))
 (if (not (null temp)) (setf rt (append rt temp))))
rt))


;******** analysis v 28/06/89  ***************
; does the patient match the age-group of the diseases ?

(defun check-the-age-group ()
  (let ((temp-list *probable-diseases*) (age (get-the-age-group))
        (dis-struct nil) (range nil))
    (setq *age-probable* nil *no-age* nil *out-of-age* nil)
    (dolist (dis (setf temp-list (make-sure-list temp-list)))
      (setf dis-struct (get-struct *all-disease* dis 'name))
      (setf range (get-slot-value 'age-groups dis-struct))
      (cond ((null range)
             (setq *no-age* (cons (name dis-struct) *no-age*)))
            ((in-range age range)
             (setf *age-probable* (cons (name dis-struct) *age-probable*)))
            (t  (setq *out-of-age* (cons (name dis-struct) *out-of-age*)))))
    (print-age-results)))

(defun print-age-results ()
  (format t "~%continue with <RETURN>~%")
  (if (null *age-probable*) nil  (print-age-probable))
  (if (null *no-age*) nil  (print-no-age))
  (if (null *out-of-age*) nil  (print-out-of-age)))

(defun print-age-probable ()
  (format t "~%diseases with congruent age-groups are :~%")
  (print-list (remove-duplicates *age-probable*))
  (wait-for-answer))

(defun print-no-age ()
  (format t "~%diseases with missing age-groups are :~%")
  (print-list (remove-duplicates *no-age*))
  (wait-for-answer))

(defun print-out-of-age ()
  (format t "~%diseases outside the current age-groups are :~%")
  (print-list (remove-duplicates *out-of-age*))
  (wait-for-answer))

(defun in-range (age range)          ; missing age-check for weeks/months
  (do ((age-list range (cddr age-list)))
      ((null age-list) nil)
    (cond ((and (>= age (first age-list)) (<= age (second age-list)))
           (return t))
          (t nil))))

(defun get-the-age-group ()
  (let ((age nil))
    (format t "~%DISEASE-ANALYSIS~%")
    (format t "~%input age of patient~%")
    (setf age (read))
    (cond ((numberp age) age)
          (t (get-the-age-group)))))

;****** xlisp functions **********

(defun substitute (new old s &key (test #'eql))
  (case (type-of s)
    (string (string:substitute new old s :test test))
    (cons (subst new old s :test test))
    ))

(defun my-intersection (x y)
(let ((result nil))
  (dolist (a (make-sure-list x))
    (if (member a y)
          (setf result (cons a result))))
  result))


(defun set-difference (x y &key (test #'eql))
  (if x
      (let*
       ((uh (car x))
 (recursion
          (set-difference (remove uh x :test test)
                          (remove uh y :test test) :test test)))
       (if (member uh y :test test)
    recursion
    (cons uh recursion)))))

(defun union (s1 s2 &key (test #'eql))
  (if s1
      (adjoin (car s1) (union (cdr s1) s2 :test test) :test test)
      s2))

(defun string:substitute (new old string &key (test #'eql))
  (let ((big (length string)))
    (if (> big 0)
        (dotimes (i big string)
          (let ((c (char string i)))
            (if (funcall test c old)
                (return
                  (strcat (subseq string 0 i)
                          (char->string new)
                          (string:substitute new
                                             old
                                             (subseq string (1+ i))))))))
        string)))

(defun char->string (c) (string c))

(setq *declared-globals* nil)

(defmacro defvar (variable-name &optional value)
  `(progn
     (if (not (member ',variable-name *declared-globals*))
         (push ',variable-name *declared-globals*))
     (setq ,variable-name ,value)
     (putprop ',variable-name 'variable 'binding)
     ))

(defmacro defconstant (constant-name &optional value)
  `(progn
     (if (not (member ',constant-name *declared-globals*))
         (push ',constant-name *declared-globals*))
     (setq ,constant-name ,value)
     (putprop ',constant-name 'constant 'binding)
     ))

(defvar *declared-globals*)


;******** list / string manipulation ************
; copied from Larry Mulcahy UL.ARC

(defun list-to-string (l)
  (if (null l)
      ""
      (if (equal (length l) 1)
          (symbol-name (car l))
          (concatenate 'string
                       (symbol-name (car l))
                       " "
                       (list-to-string (cdr l))))))

(defun zap-to-string (uh)
  (cond
    ((listp uh) (list-to-string uh))
    ((symbolp uh) (symbol-name uh))
    ((numberp uh) (number-to-string uh))
    (t (string uh))))

(defun list-to-string (ll)
  (cond ((null ll) "")
        ((equal (length ll) 1) (zap-to-string (car ll)))
        (t (concatenate 'string (zap-to-string (car ll)) " "
                        (list-to-string (cdr ll))))))

(defun number-to-string (n)
  (case (type-of n)
    (float  (if (> (abs n) 100000.0)
                (primitive-number-to-string (round n))
                (if (< (abs n) 1.0) (format nil "~F" (trim-float n 8))
                    (format nil "~F" (trim-float n 2)))))
    (ratio  (if (> (abs n) 100)
                (number-to-string (coerce n 'float))
                (multiple-value-bind
                    (whole fraction) (truncate n)
                  (if (= fraction 0) (format nil "~D" whole)
                      (format nil "~D-~D" whole fraction)))))
    (otherwise (primitive-number-to-string n))))

(defun primitive-number-to-string (n)
  (let ((stream (make-string-output-stream)))
    (princ n stream)
    (get-output-stream-string stream)))

(defun trim-float (x digits)
  (let ((magnitude (expt 10 digits)))
    (/ (fround (* x magnitude)) magnitude)))